home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-19 / pkey12_1.zip / COL.LSP < prev    next >
Text File  |  1992-09-13  |  2KB  |  54 lines
  1. ;Add Columns and Grid Patterns
  2. ;
  3. ;
  4. (defun dtr (a1)
  5. (* pi (/ a1 180.0)))
  6. (setq oer *error* *error* err)
  7. (pre)
  8. (If(= gx nil)(setq *gx 120))
  9. (setq gx(getdist(strcat "X -  grid spacing <"(rtos *gx)">: ")))
  10. (if(= gx nil)(setq gx *gx)(setq *gx gx))
  11. (if(= gy nil)(setq *gy 120))
  12. (setq gy(getdist(strcat "Y -  grid spacing <"(rtos *gy)">: ")))
  13. (if(= gy nil)(setq gy *gy)(setq *gy gy))
  14. (setq xa(atof(getstring "\nX - column size. :")))
  15. (setq ya(atof(getstring(strcat "\nY - column size. <"(rtos xa)"):"))))
  16. (if (= ya 0.0)(setq ya xa))
  17. (if (= *cb nil)(setq *cb "S")
  18. (setq cb *cb))
  19. (setq colblk(getstring(strcat"\n(C)ircle. (S)quare. :< ")(prompt *cb)(prompt "\ >")
  20. (princ)))
  21. (if(= colblk "")(setq colblk *cb)(setq *cb colblk))
  22. (If(or(= colblk "s")(= colblk "s"))(setq colblk "colsqr"))
  23. (if(or(= colblk "c")(= colblk "c"))(setq colblk "colcir"))
  24. (setq p1(getpoint "Pick lower left column grid limit. : "))
  25. (Setq p0(getpoint "Pick upper right column grid limit. : "))
  26. (Setq c(distance p1 p0))
  27. (setq a1(angle p1 p0))
  28. (setq b(* c(sin a1)))
  29. (setq a(* c(cos a1)))
  30. (setq aa(-(fix(/ a gx))1))
  31. (if(= aa 0)(setq aa(+ aa 1)))
  32. (setq d(/(- a(* aa gx))2))
  33. (setq p2(list(+(car p1)d)(cadr p1)))
  34. (setq p3(list(car p2)(+(cadr p2)b)))
  35. (setq bb(-(fix(/ b gy))1))
  36. (if(= bb 0)(setq bb(+ bb 1)))
  37. (setq db(/(- b(* bb gy))2))
  38. (setq p4(list(car p1)(+(cadr p1)db)))
  39. (setq p5(list(+(car p4)a)(cadr p4)))
  40. (setq ip(list(+(car p4)d)(cadr p4)))
  41. (command"layer""S""cg""")
  42. (command "line" p2 p3 "")
  43. (command "array" "l" "" "r" "1"(+ aa 1)gx)
  44. (command "line" p4 p5 "")
  45. (command "array" "l" "" "r"(+ bb 1)"1" gy)
  46. (setq cb1(strcat "\\kesym1\\" colblk))
  47. (command"layer" "s" "ew" "")
  48. (command"insert" cb1 ip xa ya "0")
  49. (command"array" "l" "" "r""1"(+ aa 1)gx)
  50. (setq a1 (angle p2 p3))
  51. (setq wd (/(distance p1 p2)2))
  52. (setq wp (polar p5 (+ a1 (dtr 0)) wd))
  53. (command "array" "w" p1 wp "r" p4 "" "r"(+ bb 1)"1" gy)
  54. (post)(setq p0 nil a nil aa nil b nil p1 nil p2 nil p3 nil bb nil db nil p4 nil p5 nil ip nil cb1 nil a1 nil wd nil wp nil)(princ)